home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1 / lisp / mac / about.el next >
Encoding:
Text File  |  1994-03-08  |  5.1 KB  |  151 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; This file is part of a Macintosh port of GNU Emacs.
  3. ;;; Copyright (C) 1993, 1994 Marc Parmet.  All rights reserved.
  4. ;;;
  5. ;;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  8. ;;; GNU General Public License for more details.
  9. ;;;
  10.  
  11. (defun have-color-QuickDraw ()
  12.   (let* ((response-string (make-string 4 0))
  13.          (err (Gestalt gestaltQuickdrawVersion response-string))
  14.          (response-int (c:value (c:deref (c:cast '(ptr . long) response-string)))))
  15.     (and (zerop err) (>= response-int gestalt8BitQD))))
  16.  
  17. (defun main-device-depth ()
  18.   (let* ((main-device (c:cast 'GDHandle (GetMainDevice)))
  19.          (pixmap (unwind-protect
  20.                      (progn (HLock (c:value main-device))
  21.                             (c:deref (c:getf (c:deref main-device) 'gdPMap)))
  22.                    (HUnlock (c:value main-device))))
  23.          (pixel-size (unwind-protect
  24.                          (progn (HLock (c:value pixmap))
  25.                                 (c:deref (c:getf (c:deref pixmap) 'pixelSize)))
  26.                        (HUnlock (c:value pixmap)))))
  27.     (c:value pixel-size)))
  28.  
  29. (c:defstruct vers (((array char 4) b)
  30.                    (short country)
  31.                    ((array unsigned-char 256) s1)
  32.                    ((array unsigned-char 256) s2)))
  33.  
  34. (defun draw-version (d item)
  35.   (let* ((type (make-string 2 0))
  36.          (h (make-string 4 0))
  37.          (box (make-rect)))
  38.     (GetDItem d item type h box)
  39.     (SetPort d)
  40.     (TextFont times)
  41.     (TextSize 14)
  42.     (let* ((u (GetResource "STR " 129))
  43.            (x (unwind-protect
  44.                   (progn (HLock u)
  45.                          (extract-internal (deref u) 0 'pascal-string))
  46.                 (HUnlock u)))
  47.            (v (GetResource "vers" 1))
  48.            (w (unwind-protect
  49.                   (progn (HLock v)
  50.                          (let* ((vers-handle (c:cast '(ptr ptr . vers) v))
  51.                                 (vers-str (c:deref (c:getf (c:deref vers-handle) 's1))))
  52.                            (extract-internal (c:value vers-str) 0 'pascal-string)))
  53.                 (HUnlock v)))
  54.            (s (CtoPstr (concat x w))))
  55.       (MoveTo (/ (- (+ (c:slotref 'Rect box 'left) (c:slotref 'Rect box 'right))
  56.                     (StringWidth s))
  57.                  2)
  58.               (- (c:slotref 'Rect box 'bottom) 4))
  59.       (DrawString s))))
  60.  
  61. (defun draw-copyright (d item)
  62.   (let* ((type (make-string 2 0))
  63.          (h (make-string 4 0))
  64.          (box1 (make-rect))
  65.          (p (GetPicture 130))
  66.          (box2 (unwind-protect
  67.                    (progn (HLock p)
  68.                           (extract-internal (deref p) 2 'string (c:sizeof 'Rect)))
  69.                  (HUnlock p))))
  70.     (GetDItem d item type h box1)
  71.     (SetPort d)
  72.     (OffsetRect box2 (- (c:slotref 'Rect box1 'left) (c:slotref 'Rect box2 'left))
  73.                 (- (c:slotref 'Rect box1 'top) (c:slotref 'Rect box2 'top)))
  74.     (if (and (have-color-QuickDraw) (>= (main-device-depth) 4))
  75.         (let ((bitmap (make-string (c:sizeof 'BitMap) 0))
  76.               (bounds-rect (copy-sequence box2))
  77.               (port (NewPtr (c:sizeof 'GrafPort))))
  78.           (if (zerop (MemError))
  79.               (progn
  80.                 (OpenPort port)
  81.                 (OffsetRect bounds-rect (- (c:slotref 'Rect bounds-rect 'left))
  82.                             (- (c:slotref 'Rect bounds-rect 'top)))
  83.                 (c:slotset 'BitMap bitmap 'rowBytes (* (1+ (/ (1- (c:slotref 'Rect bounds-rect 'right)) 16)) 2))
  84.                 (c:slotset 'BitMap bitmap 'bounds bounds-rect)
  85.                 (let* ((baseAddr (NewPtr (* (c:slotref 'BitMap bitmap 'rowBytes)
  86.                                             (c:slotref 'Rect (c:slotref 'BitMap bitmap 'bounds) 'bottom))))
  87.                        (grey (let ((shade 55000)) (make-rgb shade shade shade)))
  88.                        (white (let ((shade 65535)) (make-rgb shade shade shade))))
  89.                   (if (zerop (MemError))
  90.                       (progn
  91.                         (c:slotset 'BitMap bitmap 'baseAddr baseAddr)
  92.                         (SetPortBits bitmap)
  93.                         (EraseRect bounds-rect)
  94.                         (DrawPicture p bounds-rect)
  95.                         (SetPort d)
  96.                         (RGBBackColor grey)
  97.                         (CopyBits bitmap (c:slotref 'GrafPort d 'portBits)
  98.                                   bounds-rect box2 0 0)
  99.                         (RGBBackColor white)
  100.                         (DisposPtr baseAddr))))
  101.                 (ClosePort port)
  102.                 (DisposPtr port))))
  103.       (DrawPicture p box2))
  104.     (FrameRect box2)))
  105.  
  106. (defun about-filter (d e i)
  107.   (cond
  108.    ((= (c:slotref 'EventRecord e 'what) mouseDown)
  109.     (SetPort d)
  110.     (let ((pt (c:slotref 'EventRecord e 'where)))
  111.       (GlobalToLocal pt)
  112.       (if (PtInRect pt (c:slotref 'GrafPort d 'portRect))
  113.           (progn
  114.             (while (not (zerop (WaitMouseUp)))
  115.               nil)
  116.             (encode-internal i 0 'short 1)
  117.             1)
  118.         0)))
  119.    ((= (c:slotref 'EventRecord e 'what) keyDown)
  120.     (let ((c (logand (c:slotref 'EventRecord e 'message) charCodeMask)))
  121.       (if (or (= c 13) (= c 3))
  122.           (progn
  123.             (encode-internal i 0 'short 1)
  124.             1)
  125.         0)))
  126.    (t
  127.     0)))
  128.  
  129. (defun do-about (menu item)
  130.   (let ((d (GetNewDialog 128 0 -1))
  131.         (type (make-string 2 0))
  132.         (h (make-string 4 0))
  133.         (box (make-rect))
  134.         item)
  135.     (setq item (NewPtr 2))
  136.     (if (zerop (MemError))
  137.         (progn
  138.           (setq dialog-user-item-callback-proc-list (list (cons 1 (function draw-version))
  139.                                                           (cons 2 (function draw-copyright))))
  140.           (GetDItem d 1 type h box)
  141.           (SetDItem d 1 (extract-internal type 0 'short) dialog-user-item-callback box)
  142.           (GetDItem d 2 type h box)
  143.           (SetDItem d 2 (extract-internal type 0 'short) dialog-user-item-callback box)
  144.           (ShowWindow d)
  145.           (InitCursor)
  146.           (encode-internal item 0 'short 0)
  147.           (while (zerop (extract-internal item 0 'short))
  148.             (ModalDialog (function about-filter) item))
  149.           (DisposPtr item)
  150.           (DisposeDialog d)))))
  151.